home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 4
/
Aminet 4 - November 1994.iso
/
aminet
/
dev
/
obero
/
oberon_lib.lha
/
oberon-a
/
source1.lha
/
source
/
AmigaUtil
/
IntuiUtil.mod
< prev
next >
Wrap
Text File
|
1994-08-08
|
17KB
|
658 lines
(***************************************************************************
$RCSfile: IntuiUtil.mod $
Description: Support for clients of intuition.library
Created by: fjc (Frank Copeland)
$Revision: 3.2 $
$Author: fjc $
$Date: 1994/08/08 16:09:54 $
Copyright © 1994, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
***************************************************************************)
MODULE IntuiUtil;
(*
** $C- CaseChk $I- IndexChk $L+ LongAdr $N- NilChk
** $P- PortableCode $R- RangeChk $S- StackChk $T- TypeChk
** $V- OvflChk $Z- ZeroVars
*)
IMPORT
E := Exec, G := Graphics, L := Layers, I := Intuition,
U := Util, SYS := SYSTEM;
(* Passed as a parameter to GetMenuChoice () *)
TYPE
Choice * = RECORD
menuChosen * : INTEGER;
itemChosen * : INTEGER;
subItemChosen * : INTEGER;
pointer * : I.MenuItemPtr;
END; (* ChoiceType *)
CONST
halfPot = I.maxPot DIV 2;
halfBody = I.maxBody DIV 2;
VAR
autoIntuiText : I.IntuiText;
(* ===== Preferences ===== *)
(*------------------------------------*)
PROCEDURE PrefsFontHeight * () : SHORTINT;
(*
Returns the height of the default system font.
*)
VAR
prefsBuffer : I.Preferences;
BEGIN
SYS.PUTREG (0, I.base.GetPrefs (prefsBuffer, SIZE(I.Preferences)));
RETURN prefsBuffer.fontHeight;
END PrefsFontHeight;
(* ===== Gadget ===== *)
(*------------------------------------*)
PROCEDURE CentreGadget *
( VAR gadget : I.Gadget; left, top, width, height : INTEGER );
(*
Adjusts the gadget's position to centre it within a rectangle defined by
(left, top, width, height).
*)
BEGIN (* CentreGadget *)
gadget.leftEdge := ( ( width - gadget.width ) DIV 2 ) + left;
gadget.topEdge := ( ( height - gadget.height ) DIV 2 ) + top;
END CentreGadget;
(*------------------------------------*)
PROCEDURE ConvertPot *
( potValue, totalUnits, visibleUnits : INTEGER )
: INTEGER;
VAR
value, hidden : LONGINT;
BEGIN (* ConvertPot *)
IF (potValue = 0) THEN
RETURN 0
ELSE
IF (visibleUnits >= totalUnits) THEN
RETURN 0
ELSE
IF potValue < 0 THEN value := potValue + 010000H
ELSE value := potValue
END;
hidden := totalUnits - visibleUnits;
RETURN SHORT ((hidden * value + halfPot) DIV I.maxPot)
END; (* ELSE *)
END; (* ELSE *)
END ConvertPot;
(*------------------------------------*)
PROCEDURE ConvertToPot *
( units, totalUnits, visibleUnits : INTEGER )
: INTEGER;
VAR
hidden, lUnits : LONGINT;
BEGIN (* ConvertToPot *)
IF units = 0 THEN
RETURN 0
ELSE
IF visibleUnits >= totalUnits THEN
RETURN 0
ELSE
IF units < 0 THEN lUnits := units + 010000H
ELSE lUnits := units
END;
hidden := totalUnits - visibleUnits;
IF lUnits >= hidden THEN
RETURN (*I.maxPot*) -1
ELSE
RETURN SHORT ((I.maxPot * lUnits) DIV hidden)
END; (* ELSE *)
END; (* ELSE *)
END; (* ELSE *)
END ConvertToPot;
(*------------------------------------*)
PROCEDURE ConvertBody * (bodyValue, totalUnits : INTEGER) : INTEGER;
VAR value : LONGINT;
BEGIN (* ConvertBody *)
IF bodyValue = 0 THEN
RETURN 0
ELSIF (bodyValue = I.maxBody) OR (totalUnits < 2) THEN
RETURN totalUnits
ELSE
IF bodyValue < 0 THEN value := bodyValue + 010000H
ELSE value := bodyValue
END;
RETURN SHORT ((totalUnits * value) DIV I.maxBody);
END
END ConvertBody;
(*------------------------------------*)
PROCEDURE ConvertToBody * ( totalUnits, visibleUnits : INTEGER ) : INTEGER;
BEGIN (* ConvertToBody *)
IF visibleUnits = 0 THEN
RETURN 0
ELSIF visibleUnits >= totalUnits THEN
RETURN (*I.maxBody*) -1
ELSE
RETURN SHORT ((I.maxBody * visibleUnits) DIV totalUnits)
END; (* ELSE *)
END ConvertToBody;
(*------------------------------------*)
(* $D- *)
PROCEDURE SetString * (VAR gadget : I.Gadget; string : ARRAY OF CHAR);
VAR
stringInfo : I.StringInfoPtr;
BEGIN (* SetString *)
stringInfo := SYS.VAL (I.StringInfoPtr, gadget.specialInfo);
SYS.MOVE
( SYS.ADR (string), stringInfo.buffer,
U.MaxInt
( SHORT (SYS.STRLEN (string) + 1), stringInfo.maxChars - 1 ) );
stringInfo.buffer [stringInfo.maxChars] := 0X
END SetString;
(*------------------------------------*)
PROCEDURE GetString * (VAR gadget : I.Gadget; VAR string : ARRAY OF CHAR);
VAR
stringInfo : I.StringInfoPtr;
BEGIN (* SetString *)
stringInfo := SYS.VAL (I.StringInfoPtr, gadget.specialInfo);
COPY (stringInfo.buffer^, string)
END GetString;
(*------------------------------------*)
PROCEDURE SetInteger * ( VAR gadget : I.Gadget; integer : LONGINT );
VAR
stringInfo : I.StringInfoPtr;
buffer : ARRAY 12 OF CHAR;
index : INTEGER;
negative : BOOLEAN;
(*------------------------------------*)
PROCEDURE Digits ( integer : LONGINT ) : INTEGER;
VAR
digits : INTEGER;
BEGIN (* Digits *)
digits := 0;
WHILE ( integer > 0 ) DO
INC( digits );
integer := integer DIV 10;
END; (* WHILE *)
RETURN digits;
END Digits;
BEGIN (* SetInteger *)
stringInfo := SYS.VAL (I.StringInfoPtr, gadget.specialInfo);
stringInfo.longInt := integer;
negative := (integer < 0); integer := ABS(integer);
index := Digits( integer );
IF negative THEN INC(index) END;
buffer [index] := 0X;
WHILE integer > 0 DO
DEC (index);
buffer[index] := CHR (integer MOD 10 + ORD ("0"));
integer := integer DIV 10;
END; (* WHILE *)
IF negative THEN buffer [0] := "-" END;
SetString (gadget, buffer);
END SetInteger;
(*------------------------------------*)
PROCEDURE GetInteger * ( VAR gadget : I.Gadget ) : LONGINT;
VAR
stringInfo : I.StringInfoPtr;
BEGIN (* GetInteger *)
stringInfo := SYS.VAL (I.StringInfoPtr, gadget.specialInfo);
RETURN stringInfo^.longInt;
END GetInteger;
(* ===== IntuiText ===== *)
(*------------------------------------*)
PROCEDURE IntuiTextHeight * ( VAR intuiText : I.IntuiText ) : INTEGER;
(*
Returns the height in scan lines of the text held in intuiText.
*)
BEGIN (* IntuiTextHeight *)
IF intuiText.iTextFont = NIL THEN
RETURN PrefsFontHeight()
ELSE
RETURN intuiText.iTextFont.ySize
END; (* ELSE *)
END IntuiTextHeight;
(*------------------------------------*)
PROCEDURE CentreIntuiText * (
VAR intuiText : I.IntuiText;
left, top, width, height : INTEGER );
(*
Adjusts the text's position to centre it within a rectangle defined by
(left, top, width, height).
*)
BEGIN (* CentreIntuiText *)
intuiText.leftEdge :=
( ( width - SHORT (I.base.IntuiTextLength(intuiText)) ) DIV 2 ) + left;
intuiText.topEdge :=
( ( height - IntuiTextHeight(intuiText) ) DIV 2 ) + top;
END CentreIntuiText;
(*------------------------------------*)
(* $D- *)
PROCEDURE CalcTextBox *
( text : ARRAY OF CHAR;
font : G.TextAttrPtr;
VAR width, height : INTEGER );
(*
Returns the minimum size of the rectangle that will enclose the given text
if rendered in the given font.
*)
VAR
intuiText : I.IntuiText;
BEGIN (* CalcTextBox *)
intuiText.iText := SYS.ADR (text);
intuiText.iTextFont := font;
width := SHORT (I.base.IntuiTextLength (intuiText));
height := IntuiTextHeight (intuiText);
END CalcTextBox;
(* ===== Window ===== *)
(*------------------------------------*)
PROCEDURE ClipWindow *
( window : I.WindowPtr;
minX, minY, maxX, maxY : INTEGER;
VAR oldRegion : G.RegionPtr )
: BOOLEAN;
(*
Sets up the window's clipping region to permit drawing only inside the
rectangle defined by (minX, minY, maxX, maxY). It returns FALSE if the
attempt fails and puts the existing clipping region in oldRegion. It
should immediately be followed by drawing routines, then
UnclipWindow( window, oldRegion ).
*)
VAR
newRegion : G.RegionPtr; myRectangle : G.Rectangle;
BEGIN (* ClipWindow *)
myRectangle.minX := minX;
myRectangle.minY := minY;
myRectangle.maxX := maxX;
myRectangle.maxY := maxY;
newRegion := G.base.NewRegion();
IF newRegion # NIL THEN
IF G.base.OrRectRegion (newRegion, myRectangle) THEN
oldRegion := L.base.InstallClipRegion (window.wLayer, newRegion);
RETURN TRUE;
END
END;
IF newRegion # NIL THEN
G.base.DisposeRegion (newRegion);
END;
RETURN FALSE;
END ClipWindow;
(*------------------------------------*)
PROCEDURE ClipWindowToBorders *
( window : I.WindowPtr; VAR oldRegion : G.RegionPtr )
: BOOLEAN;
(*
Sets up the window's clipping region to permit drawing only inside the
rectangle defined by the window's borders. It returns FALSE if the
attempt fails and puts the existing clipping region in oldRegion. It
should immediately be followed by drawing routines, then
UnclipWindow( window, oldRegion ).
*)
BEGIN (* ClipWindowToBorders *)
RETURN
ClipWindow
( window, window.borderLeft, window.borderTop,
window.width - window.borderRight - 1,
window.height - window.borderBottom - 1, oldRegion );
END ClipWindowToBorders;
(*------------------------------------*)
PROCEDURE UnclipWindow * (window : I.WindowPtr; prevRegion : G.RegionPtr);
(*
Restores a window's clipping region after a call to ClipWindow() or
ClipWindowToBorders();
*)
VAR
oldRegion : G.RegionPtr;
BEGIN (* UnclipWindow *)
oldRegion := L.base.InstallClipRegion (window.wLayer, prevRegion);
IF oldRegion # NIL THEN
G.base.DisposeRegion (oldRegion);
END
END UnclipWindow;
(*------------------------------------*)
PROCEDURE DrawWidth * ( window : I.WindowPtr ) : INTEGER;
(*
Returns the width of the window's inner drawing region.
*)
BEGIN
RETURN (window.width - window.borderLeft - window.borderRight)
END DrawWidth;
(*------------------------------------*)
PROCEDURE DrawHeight *
( window : I.WindowPtr )
: INTEGER;
(*
Returns the height of the window's inner drawing region.
*)
BEGIN
RETURN (window.height - window.borderTop - window.borderBottom)
END DrawHeight;
(*------------------------------------*)
PROCEDURE AdjustForBorders *
( window : I.WindowPtr; VAR left, top : INTEGER );
(*
Adjusts a window co-ordinate to ensure the origin is the top left of the
window's inner drawing region.
*)
BEGIN (* AdjustForBorders *)
IF ~(I.wflgGimmeZeroZero IN window.flags) THEN
INC( left, window.borderLeft); INC( top, window.borderTop)
END
END AdjustForBorders;
(*------------------------------------*)
PROCEDURE StripIntuiMessages *
( mp : E.MsgPortPtr; win : I.WindowPtr );
(*
Function to remove and reply all IntuiMessages on a port that have
been sent to a particular window (note that we don't rely on the
lnSucc pointer of a message after we have replied it).
This is from the RKM:Libraries, 3d Ed, p255.
*)
VAR msg : I.IntuiMessagePtr; succ : E.MinNodePtr;
BEGIN (* StripIntuiMessages *)
msg := SYS.VAL (I.IntuiMessagePtr, mp.msgList.head);
WHILE msg.succ # NIL DO
succ := msg.succ;
IF msg.idcmpWindow = win THEN
(*
Intuition is about to free this message. Make sure that we have
politely sent it back.
*)
E.base.Remove (msg);
E.base.ReplyMsg (msg)
END;
msg := SYS.VAL (I.IntuiMessagePtr, succ)
END
END StripIntuiMessages;
(*------------------------------------*)
PROCEDURE CloseWindowSafely *
( win : I.WindowPtr );
(*
Strip all IntuiMessages from an IDCMP which are waiting for a specific
window. When the messages are gone, set the UserPort of the window to
NIL and call ModifyIDCMP (win, {}). This will free the Intuition
parts of the IDCMP and turn off messages to this port without changing
the original UserPort (which may be in use by other windows).
This is from the RKM:Libraries, 3d Ed, p255.
*)
VAR
BEGIN (* CloseWindowSafely *)
(* We forbid here to keep out of race conditions with Intuition *)
E.base.Forbid ();
(*
Send back any messages for this window that have not yet been processed
*)
StripIntuiMessages (win.userPort, win);
(* Clear UserPort so Intuition will not free it *)
win.userPort := NIL;
(* Tell Intuition to stop sending messages *)
I.base.OldModifyIDCMP (win, {});
(* Turn multitasking back on *)
E.base.Permit ();
(* Now it's safe to really close the window *)
I.base.CloseWindow (win)
END CloseWindowSafely;
(*------------------------------------*)
PROCEDURE FindSizeGadget *
( win : I.WindowPtr; VAR width, height : INTEGER )
: BOOLEAN;
CONST
Sizing = I.gtypSysGadget + I.gtypSizing;
Mask = {4..7, 10..15};
VAR gadget : I.GadgetPtr;
BEGIN (* FindSizeGadget *)
gadget := SYS.VAL (I.GadgetPtr, win.firstGadget);
WHILE (gadget # NIL) & ((gadget.gadgetType * Mask) # Sizing) DO
gadget := SYS.VAL (I.GadgetPtr, gadget.nextGadget)
END;
IF gadget # NIL THEN
width := gadget.width; height := gadget.height
END;
RETURN (gadget # NIL)
END FindSizeGadget;
(* ===== Requesters ===== *)
(*------------------------------------*)
(* $L- reference globals through A4 *)
PROCEDURE MultiRequest *
( window : I.WindowPtr;
VAR bodyText : ARRAY OF E.APTR;
lines : INTEGER;
positiveText, negativeText : E.APTR )
: BOOLEAN;
CONST
NoFlags = {};
ExtraWidth = 32;
ExtraHeight = 22;
VAR
newTextPtr, bodyTextPtr, positiveTextPtr, negTextPtr : I.IntuiTextPtr;
positiveIntuiText, negativeIntuiText : I.IntuiText;
textHeight, maxLength, width, height : INTEGER;
memory : I.RememberPtr;
result : BOOLEAN;
BEGIN (* MultiRequest *)
IF (lines > 0) THEN
IF positiveText # NIL THEN
positiveIntuiText := autoIntuiText;
positiveIntuiText.iText := positiveText;
positiveTextPtr := SYS.BIND (I.IntuiTextPtr, positiveIntuiText);
ELSE
positiveTextPtr := NIL;
END;
IF negativeText # NIL THEN
negativeIntuiText := autoIntuiText;
negativeIntuiText.iText := negativeText;
negTextPtr := SYS.BIND (I.IntuiTextPtr, negativeIntuiText);
ELSE
RETURN FALSE
END;
memory := NIL;
bodyTextPtr := NIL;
maxLength := 0;
textHeight := PrefsFontHeight() + 1;
height := ((lines + 2) * textHeight) + ExtraHeight;
WHILE lines > 0 DO
newTextPtr := I.base.AllocRemember (memory, SIZE(I.IntuiText), {});
IF newTextPtr # NIL THEN
DEC (lines);
newTextPtr^ := autoIntuiText;
INC (newTextPtr^.topEdge, lines * textHeight);
newTextPtr.iText := bodyText [lines];
newTextPtr.nextText := bodyTextPtr;
maxLength :=
U.MaxInt
(maxLength, SHORT (I.base.IntuiTextLength(newTextPtr^)));
bodyTextPtr := newTextPtr;
ELSE
I.base.FreeRemember (memory, E.LTRUE);
RETURN FALSE;
END
END; (* WHILE *)
width := maxLength + ExtraWidth;
result :=
I.base.AutoRequest
( window, bodyTextPtr, positiveTextPtr, negTextPtr, NoFlags,
NoFlags, width, height );
I.base.FreeRemember (memory, E.LTRUE);
RETURN result;
ELSE
RETURN FALSE;
END
END MultiRequest;
(* $L+ absolute long addressing for globals *)
(*------------------------------------*)
PROCEDURE SimpleRequest * (
window : I.WindowPtr;
bodyText, positiveText, negativeText : E.APTR )
: BOOLEAN;
VAR
bodyTextArray : ARRAY 1 OF E.APTR;
BEGIN (* SimpleRequest *)
IF bodyText # NIL THEN
bodyTextArray [0] := bodyText;
RETURN
MultiRequest (window, bodyTextArray, 1, positiveText, negativeText);
ELSE
RETURN FALSE;
END
END SimpleRequest;
(*------------------------------------*)
PROCEDURE SimpleNotice *
( window : I.WindowPtr; bodyText : E.APTR );
BEGIN (* SimpleNotice *)
SYS.PUTREG (0, SimpleRequest (window, bodyText, NIL, SYS.ADR("Continue")))
END SimpleNotice;
(*------------------------------------*)
PROCEDURE MultiNotice *
( window : I.WindowPtr; VAR bodyText : ARRAY OF E.APTR; lines : INTEGER );
BEGIN (* MultiNotice *)
SYS.PUTREG
(0, MultiRequest (window, bodyText, lines, NIL, SYS.ADR("Continue")))
END MultiNotice;
(* ===== Menus ===== *)
(*------------------------------------*)
PROCEDURE GetMenuChoice *
( menuSelection : INTEGER;
VAR firstMenu : I.Menu;
VAR menuChoice : Choice );
BEGIN (* GetMenuChoice *)
menuChoice.menuChosen := (menuSelection MOD 32);
menuChoice.itemChosen := (SYS.LSH (menuSelection, -5) MOD 64);
menuChoice.subItemChosen := (SYS.LSH (menuSelection, -11) MOD 32);
menuChoice.pointer := I.base.ItemAddress (firstMenu, menuSelection);
END GetMenuChoice;
(* $L- reference globals through A4 *)
BEGIN (* IntuiUtil *)
autoIntuiText.leftEdge := I.autoLeftEdge;
autoIntuiText.topEdge := I.autoTopEdge;
autoIntuiText.frontPen := I.autoFrontPen;
autoIntuiText.backPen := I.autoBackPen;
autoIntuiText.drawMode := I.autoDrawMode;
autoIntuiText.iTextFont := I.autoITextFont;
autoIntuiText.iText := NIL;
autoIntuiText.nextText := I.autoNextText;
END IntuiUtil.